-- Copyright 2012, Google Inc.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of Google Inc. nor the names of its contributors may
--       be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.

-- Author: Paul Brauner (polux@google.com)

import Text.Regex.PCRE ((=~~))
import Data.List
import Data.Array.Unboxed

import qualified Data.Map as M
import Control.Applicative
import Control.Monad
import Control.Monad.Par

import Data.Binary
import System.IO
import Debug.Trace(traceShow)
import System.Environment (getArgs)

{- parallel mapreduce over lists -}

la :: (Int, Int) -> [a] -> Array Int a
la = listArray

--mapReduce f binop z xs = foldr binop z (map f xs)

parMapReduce f bin z xs =
  parMapReduceRangeThresh 1000 (InclusiveRange 1 len) f' bin' z
  where len = length xs
        xsArray = la (1, len) xs
        f' i = return $ f (xsArray ! i)
        bin' x y = return (bin x y)


{- datatypes -}

type SurName = String
type Name = String
type Wrd = String
type SurNamePhonex = String
type SuffixPhonex = String
-- maps phonexes to words
type NDict = M.Map SurNamePhonex [SurName]
-- maps phonexes of suffixes to a map from prefix phonexes
-- to corresponding original word
type SDict = M.Map SuffixPhonex (M.Map SurNamePhonex [Wrd])
type DataBase = (SDict, NDict)

{- phonex -}

-- Found at http://mutelight.org/articles/generating-a-permalink-slug-in-haskell.html
replace :: String -> String -> String -> String
replace regex replacement text = go text []
  where go str res =
          if null str
          then concat . reverse $ res
          else case (str =~~ regex) :: Maybe (String, String, String) of
            Nothing -> concat . reverse $ (str:res)
            Just (bef, _ , aft) -> go aft (replacement:bef:res)

rmdups = map head . group

steps =
  [ replace "y" "i"
  , replace "(?<=[^csp])h" ""
  , replace "ph" "f"
  , replace "ga(?=(n|m|in|im))" "ka"
  , replace "(ain|ein|aim|eim)(?=(a|e|i|o|u))" "yn"
  , replace "eau" "o"
  , replace "oua" "2"
  , replace "(ein|ain|eim|aim)" "4"
  , replace "(é|è|ê|ai|ei)" "y"
  , replace "er" "yr"
  , replace "ess" "yss"
  , replace "et" "yt"
  , replace "(an|am|en|em)(?=[^(a|e|i|o|u|1|2|3|4)])" "1"
  , replace "in(?=[^(a|e|i|o|u|1|2|3|4)])" "4"
  , replace "(oe|eu)" "e"
  , replace "au" "o"
  , replace "(oi|oy)" "2"
  , replace "ou" "3"
  , replace "(ch|sch|sh)" "5"
  , replace "(ss|sc)" "s"
  , replace "c(?=(e|i))" "s"
  , replace "(c|q|qu|gu)" "k"
  , replace "g(?=(a|o|y))" "k"
  , replace "a" "o"
  , replace "(d|p)" "t"
  , replace "j" "g"
  , replace "(b|v)" "f"
  , replace "m" "n"
  , rmdups
  , replace "(t|x)$" ""
  ]

phonex bs = foldl' step bs steps
  where step s f = f s

{- database construction -}

parts l = zip (inits l) (tails l)

ndict :: [SurName] -> NDict
ndict = M.fromListWith (++) . map convert
  where convert w = (phonex w ,[w])

sdict' :: NDict -> Wrd -> SDict
sdict' d w = M.fromListWith (M.unionWith (++))
  [ (sufph, M.singleton preph [w])
  | (pre, suf) <- parts w
  , let sufph = phonex suf
  , let preph = phonex pre
  , preph `M.member` d ]


sdict :: NDict -> [Wrd] -> SDict
sdict d ws = runPar $ parMapReduce f bin M.empty ws
  where f = sdict' d
        bin = M.unionWith (M.unionWith (++))

mkdb :: [Name] -> [Wrd] -> DataBase
mkdb ns ws = traceShow (M.size nd) (sdict nd ws, nd)
  where nd = ndict ns

{- database IO -}

makeDbFrom :: FilePath -> FilePath -> IO DataBase
makeDbFrom fn fw = mkdb <$> (pre <$> readFile fn) <*> (pre <$> readFile fw)
  where pre = words

writeDbTo :: DataBase -> FilePath -> IO ()
writeDbTo = flip encodeFile

genDb firstnames frenchWords fn = do
  db <- makeDbFrom firstnames frenchWords
  writeDbTo db fn

readDbFrom :: FilePath -> IO DataBase
readDbFrom = decodeFile

{- queries -}

play :: DataBase -> Name -> [(SurName, [Wrd])]
play (sd, nd) name =
  case phonex name `M.lookup` sd of
    Just prephs -> [(firstname,orig)
                   | (preph, orig) <- M.toList prephs
                   , firstname <- M.findWithDefault [] preph nd]
    Nothing     -> []

pretty :: (String, [String]) -> String
pretty (firstname, wrds) =
  firstname ++ " (" ++
  intercalate "," wrds ++ ")"

loop d = do putStr "\nenter a name\n> "
            hFlush stdout
            name <- getLine
            play d name `forM_` (putStrLn . pretty)
            loop d

usage = "Usage: hpuns existing_db\n\
        \    or hpuns first_names french_words db_to_generate"

main = do
  args <- getArgs
  case args of
    [db] -> do
      putStrLn $ "loading " ++ db
      readDbFrom db >>= loop
    [firstnames, frenchWords, db] -> do
      putStrLn $ "generating " ++ db
      genDb firstnames frenchWords db
    _ -> do
      putStrLn usage
